home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / byte0487.arc / TELLO.ARC / DERIV.LSP < prev    next >
Encoding:
Text File  |  1980-01-01  |  2.3 KB  |  98 lines
  1. ; DERIV
  2.  
  3. (DEFUN deriv-aux (A) (LIST '/ (DERIV A) A))
  4.  
  5. (DEFUN DERIV (A)
  6.   (COND
  7.     ((ATOM A)
  8.      (COND ((EQ A 'X) 1) (T 0)))
  9.     ((EQ (CAR A) '+)
  10.      (CONS '+ (MAPCAR #'DERIV (CDR A))))
  11.     ((EQ (CAR A) '-)
  12.      (CONS '- (MAPCAR #'DERIV (CDR A))))
  13.     ((EQ (CAR A) '*)
  14.      (LIST '*
  15.        A
  16.        (CONS '+ (MAPCAR 'deriv-aux (CDR A)))))
  17.     ((EQ (CAR A) '/)
  18.      (LIST '-
  19.        (LIST '/
  20.          (DERIV (CADR A))
  21.          (CADDR A))
  22.        (LIST '/
  23.          (CADR A)
  24.          (LIST '*
  25.                (CADDR A)
  26.                (CADDR A)
  27.                (DERIV (CADDR A))))))
  28.     (T 'ERROR)))
  29.  
  30. (DEFUN RUN-deriv ()
  31.   (DO ((I 0 (1+ I)))
  32.       ((= I 1000.))
  33.     #-GCLisp (DECLARE (type FIXNUM I))
  34.     (DERIV '(+ (* 3 X X) (* A X X) (* B X) 5))
  35.     (DERIV '(+ (* 3 X X) (* A X X) (* B X) 5))
  36.     (DERIV '(+ (* 3 X X) (* A X X) (* B X) 5))
  37.     (DERIV '(+ (* 3 X X) (* A X X) (* B X) 5))
  38.     (DERIV '(+ (* 3 X X) (* A X X) (* B X) 5))))
  39.  
  40. (define-timer deriv "Deriv" (run-deriv))
  41. (qa-attempt "Deriv" (run-deriv) nil)
  42.  
  43.  
  44. ;;; 3.11 DDERIV
  45.  
  46. (DEFUN dderiv-aux (A) (LIST '/ (DDERIV A) A))
  47.  
  48. (DEFUN +DDERIV (A)
  49.   (CONS '+ (MAPCAR #'DDERIV A)))
  50.  
  51. (DEFUN -DDERIV (A)
  52.   (CONS '- (MAPCAR #'DDERIV A)))
  53.  
  54. (DEFUN *DDERIV (A)
  55.     (LIST '* (CONS '* A)
  56.         (CONS '+ (MAPCAR #'dderiv-aux A))))
  57.  
  58. (DEFUN /DDERIV (A)
  59.        (LIST '-
  60.          (LIST '/
  61.            (DDERIV (CAR A))
  62.            (CADR A))
  63.          (LIST '/
  64.            (CAR A)
  65.            (LIST '*
  66.              (CADR A)
  67.              (CADR A)
  68.              (DDERIV (CADR A))))))
  69.  
  70. (DEFUN DDERIV (A)
  71.   (COND
  72.     ((ATOM A)
  73.      (COND ((EQ A 'X) 1) (T 0)))
  74.     (T (LET ((DDERIV (GET (CAR A) 'DDERIV)))
  75.      (COND (DDERIV (FUNCALL DDERIV (CDR A)))
  76.            (T 'ERROR))))))
  77.  
  78. (defun setup-dderiv ()
  79.   (mapc #'(lambda (op fun)
  80.        (setf (get op 'dderiv) (symbol-function fun)))
  81.     '(+ - * /)
  82.     '(+dderiv -dderiv *dderiv /dderiv)))
  83.  
  84. (setup-dderiv)
  85.  
  86. (DEFUN RUN-dderiv ()
  87.   (DO ((I 0 (1+ I)))
  88.       ((= I 1000.))
  89.     #-GCLisp (DECLARE (type FIXNUM I))
  90.     (DDERIV '(+ (* 3 X X) (* A X X) (* B X) 5))
  91.     (DDERIV '(+ (* 3 X X) (* A X X) (* B X) 5))
  92.     (DDERIV '(+ (* 3 X X) (* A X X) (* B X) 5))
  93.     (DDERIV '(+ (* 3 X X) (* A X X) (* B X) 5))
  94.     (DDERIV '(+ (* 3 X X) (* A X X) (* B X) 5))))
  95.  
  96. (define-timer dderiv "DDeriv" (run-dderiv))
  97. (qa-attempt "DDeriv" (run-dderiv) nil)
  98.